home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / オンラインソフト定点観測 / ユーティリティ / Mops 3.2.sea / Mops 3.2 / Mops source / PPC source / pnuc2 < prev    next >
Text File  |  1998-06-13  |  16KB  |  845 lines

  1. marker m__pnuc2
  2.  
  3. ¥                    ======================
  4. ¥                               I/O
  5. ¥                    ======================
  6.  
  7.  
  8. 0    value    BUSY        ¥ FCB of file involved in asynchronous I/O, or zero if none.
  9.                         ¥ Set from high level, not from here.  Cleared here though,
  10.                         ¥  by the completion routine.
  11.  
  12. 0    value    CPADDR        ¥ Completion routine address, or zero if none.  Also serves
  13.                         ¥  as a flag that the next op is to be asynchronous.
  14.  
  15.  
  16. ¥ *** Actually, I'm not going to attempt asynch I/O on the PPC yet, since I
  17. ¥  don't want to have to worry about UPP callbacks!
  18.  
  19.  
  20. ¥                    ===========================
  21. ¥                        OTHER SYSTEM CALLS
  22. ¥                    ===========================
  23.  
  24. ¥ we can omit all the handle and pointer stuff here in the nucleus, and just
  25. ¥  use SYSCALLs in pStruct.
  26.  
  27. sysCall  FreeMem
  28. sysCall  MaxMem
  29. sysCall  EventAvail
  30. sysCall  WaitNextEvent
  31. sysCall  FindWindow
  32. sysCall  BlockMoveData
  33.  
  34. : FREE        FreeMem  ;
  35.  
  36.     variable    growBytes
  37.  
  38. : FREEBLK    growBytes  MaxMem  ;
  39.  
  40. : EVENT?        ¥ ( mask -- b )
  41.     fEvent  EventAvail 0<>  ;
  42.  
  43. : ?EVENT    event?  ;            ¥ legacy name
  44.  
  45. : NEXTEVENT        ¥ ( ^event mask -- b )
  46.     swap
  47.     TEidle_vect
  48.     sleepTicks
  49.     MMRgn
  50.     WaitNextEvent
  51. ;
  52.  
  53. variable  WPtr
  54.     
  55. : FIND-WINDOW    ¥ ( point -- part# ^window )
  56.     WPtr
  57.     FindWindow
  58.     WPtr @  ;
  59.  
  60.  
  61.  
  62. ¥                =========================
  63. ¥                LOW-LEVEL STRING HANDLING
  64. ¥                =========================
  65.  
  66.  
  67. : FILL  { addr len char -- }
  68.     len  0EXIT
  69.     len FOR
  70.         char  addr c!
  71.         1 ++> addr
  72.     NEXT
  73. ;
  74.  
  75. : ERASE        ¥ ( addr len -- )
  76.     0 fill  ;
  77.  
  78. : BLANKS    ¥ ( addr len -- )
  79.     $ 20  fill  ;
  80.  
  81.  
  82. : (S=)  { addr1 addr2 len -- b }
  83.     len
  84.     FOR    addr1 c@  addr2 c@  <>
  85.         IF  UNFOR  false  EXIT  THEN
  86.         1 ++> addr1  1 ++> addr2
  87.     NEXT
  88.     true  ;
  89.  
  90.  
  91.  
  92. : S=  { addr1 len1 addr2 len2 -- b }
  93.     len1 len2 =
  94.     IF        addr1 addr2 len1 (s=)
  95.     ELSE    false
  96.     THEN
  97. ;
  98.  
  99.  
  100.  
  101. (*    MOVE and ALIGNED_MOVE.
  102.     There's a small problem with MOVE in that it is required by the standard to
  103.     move the data exactly even if the areas overlap, without propagation effects.
  104.     "Undefined on overlap" would have allowed better optimization possiblities,
  105.     although there are probably some situations where the other behavior is
  106.     better.  Anyway we provide both.  We do the "undefined on overlap" with
  107.     ALIGNED_MOVE, which also requires the beginning addresses to be aligned,
  108.     which they usually are anyway.  For MOVE, we call BlockMoveData, which
  109.     does the right thing, and does it well, especially for the longer moves.
  110.     There's about a 28 instruction overhead, but the actual moves are optimum
  111.     for whatever processor we're running on.  So even for ALIGNED_MOVE, we
  112.     call BlockMoveData if the move is long, since for a long enough move there'll 
  113.     always be an advantage in using a processor-specific optimized sequence.
  114.  
  115.     We assume that we're not moving code, only data, so we use BlockMoveData
  116.     rather than BlockMove which flushes the caches.  
  117.     Note we also made this assumption on the 68k, since although we used
  118.     BlockMove (BlockMoveData not being available on all systems) if possible
  119.     we optimized small moves to some inline MOVE instructions without a cache
  120.     flush.
  121.  
  122.     Note also that in a future version the code given here for ALIGNED_MOVE 
  123.     might not always be called if the byte count is a literal.  In this case
  124.     we could sometimes generate a better inline sequence.
  125. *)
  126.  
  127.  
  128. : MOVE    ¥ ( src dst len -- )
  129.     dup NIF  drop 2drop  EXIT  THEN
  130.     BlockMoveData  ;
  131.  
  132. $ BD36 ' move  2- w!                ¥ move_h handler code
  133.  
  134. : ALIGNED_MOVE  { src dst len ¥ cnt -- }
  135.     len 0<=  ?EXIT
  136.     len 32 <=
  137.     IF    len 2 >>  -> cnt
  138.         cnt FOR        src @  dst !
  139.                     4 ++> src  4 ++> dst
  140.             NEXT
  141.         len 3 and  -> cnt
  142.         cnt FOR        src c@  dst c!
  143.                     1 ++> src  1 ++> dst
  144.             NEXT
  145.     ELSE
  146.         src dst len BlockMoveData
  147.     THEN
  148. ;
  149.  
  150. ¥ $ BD37 ' aligned_move  2- w!        ¥ alignedMove_h handler code
  151.  
  152.  
  153. : CMOVE  { src dst len -- }
  154.     len FOR
  155.         src c@  dst c!
  156.         1 ++> src  1 ++> dst
  157.     NEXT
  158. ;
  159.  
  160.  
  161. : UPPER  { addr len -- }
  162.     len FOR
  163.         addr c@
  164.         & a  & z  within?
  165.         IF    $ 20 xor  addr c!  ELSE  drop  THEN
  166.         1 ++> addr
  167.     NEXT
  168. ;
  169.  
  170.  
  171. (*    These words are used by the input parsing section.
  172.  
  173.     SCAN ( addr len c -- addr' len' ) searches the string ( addr len )
  174.     for the character c.  addr' is the address of the matching char,
  175.     and len' is the remaining length (including the matching char).  If no
  176.     match, len' will be zero.
  177.  
  178.     Class String+ provides a more complete implementation in its
  179.     chsearch: method, which has case handling.  In the 68k version,
  180.     SCAN only handles a 16-bit length - we don't have this restriction
  181.     in the PPC version, although if you exploit this feature your
  182.     code won't work on the 68k.
  183. *)
  184.  
  185.  
  186. : SCAN { addr len char -- addr' len' }
  187.  
  188.     len FOR
  189.         addr c@ char =
  190.         IF  UNFOR  addr len  EXIT  THEN
  191.         1 ++> addr  1 --> len
  192.     NEXT
  193.     addr 0
  194. ;
  195.  
  196.  
  197. : SKIP  { addr len char -- addr' len' }
  198.  
  199.     len FOR
  200.         addr c@ char <>
  201.         IF  UNFOR  addr len  EXIT  THEN
  202.         1 ++> addr  1 --> len
  203.     NEXT
  204.     addr 0
  205. ;
  206.  
  207. : /STRING  { addr len n -- addr' len' }
  208.     addr n +
  209.     len  n -
  210. ;
  211.  
  212.  
  213. ¥                ==========================
  214. ¥                    INPUT PARSING etc.
  215. ¥                ==========================
  216.  
  217. : SOURCE    ¥ ( -- addr len )
  218.     src-start src-len  ;
  219.  
  220.  
  221. : REST        ¥ ( -- addr len )
  222.     src-start    >in @ +
  223.     src-len        >in @ -
  224. ;
  225.  
  226. : SCAN-SRC  { c -- }
  227.     ¥ Scans the input stream for c.  Leaves the source
  228.     ¥ updated to the next character, (so it could be empty if the found char
  229.     ¥ was the last in the buffer) or overshot if none found (>IN exceeding
  230.     ¥ SRC-LEN).  The caller will need to check for this.
  231.  
  232.     rest c scan
  233.     src-len swap - 1+  >in !
  234.     drop  ;
  235.  
  236.  
  237. : SKIP-SRC  { c -- }
  238.     ¥ Skips consecutive delimiters equal to c in the source.
  239.     ¥ Leaves source updated to the next character, or empty if none.
  240.  
  241.     rest c skip
  242.     src-len swap -  >in !
  243.     drop  ;
  244.  
  245.  
  246. : SKIP-SRC+  { c -- }
  247.     ¥ Skips consecutive delimiters equal to c in the source.
  248.     ¥ If the source gets exhausted before a non-delimiter is found,
  249.     ¥ keeps calling REFILL to get more.
  250.  
  251.     BEGIN
  252.         c skip-src
  253.         >in @  src-len <  ?EXIT        ¥ out on success
  254.         refill                        ¥ get next input line
  255.     NUNTIL                            ¥ loop if we got it
  256.     154 die            ¥ "unexpected end of file"
  257. ;
  258.     
  259.     
  260. : PARSE  { c ¥ len -- addr len }
  261.     ¥ Scans the source for delimiter c.  Returns
  262.     ¥ the addr and len of the parsed string, and updates the source
  263.     ¥ to the remaining string.
  264.  
  265.     >in @
  266.     c scan-src
  267.     >in @  over -  1-  -> len
  268.     src-start +  len
  269. ;
  270.  
  271.  
  272. : PARSE-WORD  ( c -- addr len )
  273.     ¥ As for PARSE, but any consecutive initial delimiters are
  274.     ¥ skipped.  If the input is exhausted in the process,
  275.     ¥ REFILL is called to get more.
  276.  
  277.     dup skip-src+ parse  ;
  278.  
  279.  
  280. : PARSE-DLM-STR  { c -- addr len }
  281.     ¥ Scans the source for a string delimited at the
  282.     ¥ start and end by c.  Everything is skipped before the first delimiter.
  283.     ¥ If the source gets exhausted in the process, REFILL is called to get
  284.     ¥ more.
  285.  
  286.     BEGIN
  287.         c scan-src
  288.         >in @  src-len <
  289.         IF    c parse  EXIT  THEN        ¥ found
  290.         refill
  291.     NUNTIL
  292.     154 die            ¥ "unexpecte end of file"
  293. ;
  294.         
  295.  
  296. : "STR"  ( -- addr len )  ¥ Scans for a string delimited by "..."
  297.  
  298.     & "  parse-dlm-str  ;
  299.  
  300.  
  301. : PLACE  { addr1 len addr2 -- }
  302.     ¥ Converts string ( addr1 len ) to a counted string at addr2.
  303.     ¥ Appends 3 zero bytes, which may be needed for padding, as
  304.     ¥ well as making it a valid C string.
  305.  
  306.     addr2 len + 1+  3 erase            ¥ append zero bytes
  307.     len addr2  c!                    ¥ store count byte
  308.     addr1  addr2 1+  len  cmove        ¥ move string bytes over
  309. ;
  310.  
  311.  
  312. : WORD  { c ¥ addr -- addr }
  313.     ¥ Parses the source using c as the delimiter (using PARSE-WORD).
  314.     ¥ Moves the resulting string as a counted string to HERE, and returns
  315.     ¥ this address.
  316.  
  317.     c parse-word
  318.     CDP #align4  -> addr
  319.     addr place
  320.     addr
  321. ;
  322.  
  323.  
  324. : WORD" ( -- addr )
  325.     & "  word  ;
  326.  
  327.  
  328. : MWORD  ( -- addr )
  329.     ¥ "Mops word".  Called by DEFINED? which is called
  330.     ¥ by INTERPRET.
  331.     ¥ Calls WORD with a blank as delimiter, and converts the string
  332.     ¥ to upper case.  Leaves counted string at addr (will be HERE).
  333.  
  334.     bl word
  335.     case_in_names?  ?EXIT
  336.     dup count upper  ;
  337.  
  338.  
  339. : (,STR)  ( addr len --)
  340.     tuck here place
  341.     1+ #align4 allot  ;
  342.  
  343.  
  344. : ,STR  ( c -- )
  345.     ¥ c is delimiter.  Adds the following text until delimiter
  346.     ¥ to the DATA AREA as a counted string.
  347.     
  348.     parse  (,str)  ;
  349.  
  350.  
  351. : ,DLM-STR  ( c -- )
  352.     ¥ Scans the source for a string delimited at the
  353.     ¥ start and end by c, then adds it to the dictionary.
  354.  
  355.     parse-dlm-str  (,str)  ;
  356.  
  357.  
  358. : ,"  ( -- )        ¥ Adds text till " to the dictionary.
  359.     & "  ,str  ;
  360.  
  361.  
  362. : ,"STR"  ( -- )    ¥ Adds text delimited by " at the start and end.
  363.     & "  ,dlm-str  ;
  364.  
  365.  
  366. ¥ .( - see below, after TYPE
  367.  
  368. : (
  369.     & )  parse  2drop  ;        ppc_immediate
  370.  
  371. : ¥
  372.     0 -> src-len  ;                ppc_immediate
  373.  
  374.  
  375.  
  376. ¥                    ======================
  377. ¥                        SCREEN OUTPUT
  378. ¥                    ======================
  379.  
  380.  
  381. ¥ First, the sysCalls and low-level stuff:
  382.  
  383. sysCall  MoveTo
  384. sysCall  EraseRect
  385. sysCall  SetOrigin
  386. sysCall  Line
  387. sysCall  ScrollRect
  388. sysCall  GetPen
  389. sysCall  GetPenState
  390. sysCall  SetPenState
  391. sysCall  PenMode
  392. sysCall  DrawChar
  393. sysCall  DrawText
  394.  
  395.  
  396. : HOME
  397.     8 15  MoveTo  ;
  398.  
  399. : CLS
  400.     fpRect  EraseRect  ;
  401.  
  402. : SCROLL  { x y -- }
  403.     emit?  0EXIT
  404.     fpRect x y theRgn  ScrollRect  ;
  405.  
  406. : >ORIGIN    ¥ ( x y --)
  407.     SetOrigin  ;
  408.  
  409. : GOTOXY    ¥ ( x y -- )
  410.     MoveTo  ;
  411.  
  412. : @XY        ¥ ( -- x y )
  413.     tempVbl GetPen
  414.     tempVbl 2+ w@
  415.     tempVbl    w@
  416. ;
  417.  
  418. : .CURS  ( -- )
  419.     emit?    0EXIT
  420.     curs?    0EXIT
  421.     tempVbl GetPenState
  422.     10  PenMode
  423.     7 0  Line
  424.     tempVbl SetPenState
  425. ;
  426.  
  427.  
  428. : CONTBOT  ( -- n )
  429.     thePort $ A0 + w@  ;
  430.  
  431. : CONTTOP  ( -- n )
  432.     thePort $ 9C +  w@  ;
  433.  
  434. : #LEAD  { ¥ addr -- n }
  435.     thePort -> addr
  436.  
  437.     thePort $ 4A + w@
  438.     dup NIF        ¥ zero point size, i.e. no font set.  We just return 4 so Scroll
  439.                 ¥  doesn't crash.
  440.         drop 4  EXIT
  441.     THEN
  442.     120 *  50 +  100 /
  443. ;
  444.  
  445.  
  446. : #LINES  ( -- n )
  447.     contBot contTop -  #lead /  1-  ;
  448.  
  449.  
  450. : BOTTOM  ( -- n )
  451.     #lead #lines 1- *
  452.     15 +  contTop +  ;
  453.  
  454.  
  455. ¥            ---------------- CR -----------------
  456.  
  457. : (CR)  ( -- )
  458.     .curs
  459.     @xy  nip 8 swap
  460.     dup bottom >=
  461.     IF    0
  462.         #lead negate  scroll
  463.         gotoXY
  464.     ELSE
  465.         #lead +  gotoXY
  466.     THEN
  467.     .curs
  468. ;
  469.  
  470. ' (cr)    sVect    CRVEC
  471.  
  472. : CR    crVec  ;
  473.  
  474.  
  475. ¥            ---------------- EMIT -----------------
  476.  
  477. : (EMIT)  { c -- }
  478.     emit?  0EXIT
  479.     c  $ D =
  480.     IF    crVec
  481.     ELSE
  482.         .curs  c DrawChar  .curs
  483.     THEN
  484. ;
  485.  
  486. ' (emit)    sVect    EMITVEC
  487. ' (emit)    sVect    ECHOVEC
  488.  
  489. : EMIT        ¥ ( c -- )
  490.     1 ++> out  emitVec  ;
  491.  
  492.  
  493. ¥            ---------------- TYPE -----------------
  494.  
  495. : (TYPE)  { addr len -- }
  496.     emit?  0EXIT
  497.     .curs
  498.     addr 0 len  DrawText
  499.     .curs
  500. ;
  501.  
  502. ' (type)    sVect    TYPEVEC
  503.  
  504. : TYPE  ( addr len -- )
  505.     dup ++> out  typeVec  ;
  506.  
  507.  
  508. : .(
  509.     & )  parse  type  ;            ppc_immediate
  510.  
  511.  
  512. ¥            -------------- SPACE & SPACES ---------------
  513.  
  514. : SPACE        bl emit  ;
  515.  
  516.  
  517. : (SPACES)  { n -- }
  518.     emit?  0EXIT
  519.     n 0<=  ?EXIT
  520.     
  521.     n padLen min  -> n
  522.     pad n bl fill
  523.     pad n  (type)
  524. ;
  525.  
  526. ' (spaces)    sVect    SPVEC
  527.     
  528. : SPACES    ¥ ( n -- )
  529.     dup ++> out  spVec  ;
  530.  
  531.  
  532. ¥ We only use (BS) internally, so we don't define a BS.
  533.  
  534. : (BS)
  535.     .curs                    ¥ erases any cursor on screen
  536.     curs?  false -> curs?
  537.     @xy swap  6 -  8 max  swap
  538.     2dup gotoXY  space  gotoXY
  539.     -> curs?
  540.     .curs                    ¥ draw cursor at new position
  541. ;
  542.  
  543.  
  544. : +ECHO        true  -> echo?  ;
  545. : -ECHO        false -> echo?  ;
  546.  
  547. : +CURS        true  -> curs?  ;
  548. : -CURS        false -> curs?  ;
  549. : CURS        curs?  ;            ¥ for backward compatibility
  550.  
  551.  
  552. ¥                ===============================
  553. ¥                        KEYBOARD INPUT
  554. ¥                ===============================
  555.  
  556.  
  557. : KEY?  ( -- b )
  558.     $ 28  event?  ;
  559.  
  560. : ?TERMINAL  ( -- b )        ¥ the old name
  561.     key?  ;
  562.  
  563.  
  564. : (KEY)  { ¥ what -- c }
  565.  
  566.     BEGIN
  567.         fEvent                        ¥ addr of our event record
  568.         $ 843A                        ¥ Mask - we'll accept key down, auto-key,
  569.                                     ¥  mouse-down, high-level and OS events.
  570.         nextEvent
  571.         IF                            ¥ we've got something
  572.             fEvent w@ -> what        ¥ get What field of fEvent
  573.             what 3 =  what 5 = or
  574.             IF                        ¥ we've got a key
  575.                 fEvent 5 + c@        ¥ low byte of message field is ASCII key value
  576.                 EXIT
  577.             ELSE
  578.                 what 23 =
  579.                 IF                    ¥ High-level event - presumably oapp.
  580.                                     ¥ We'll just ignore it.
  581.                 THEN
  582.             THEN
  583.         THEN
  584.     AGAIN
  585. ;
  586.  
  587.  
  588. ' (key)    sVect    KEY
  589.  
  590. forward        get_$input
  591.  
  592. :f get_$input    pad 0  ;f
  593.  
  594.  
  595. : bs_acc
  596.     #tib @                ¥ at start of TIB?
  597.     IF    (bs)            ¥ no - fix screen
  598.         -1 #tib +!        ¥ and back up
  599.     ELSE
  600.         4 beep            ¥ yes - beep
  601.     THEN
  602. ;
  603.  
  604.  
  605. : key_acc  { ¥ c loop? -- c }
  606.         ¥ Reads one key for ACCEPT.  Handles backspaces and tabs.
  607.  
  608.     BEGIN
  609.         false -> loop?
  610.         key -> c
  611.                             ¥ first we check for the chars which we don't echo
  612.         c 8 =
  613.         IF  bs_acc                    ¥ handle backspace
  614.         ELSE
  615.             c $ FF =
  616.             IF                        ¥ ignore FF
  617.  
  618.             ELSE            ¥ we echo everything else and don't loop
  619.                 c 3 =
  620.                 IF    $ D -> c        ¥ <enter> replaced with <return>
  621.                 ELSE
  622.                     c 9 =
  623.                     IF    bl -> c        ¥ tab replaced with blank
  624.                     THEN
  625.                 THEN
  626.                 c echoVec            ¥ echo char however we're set up to do it
  627.                 c  EXIT
  628.             THEN
  629.         THEN
  630.     AGAIN
  631. ;
  632.  
  633.  
  634. : ACCEPT  { addr max_len ¥ c -- #chars }
  635.  
  636.     0 #tib !
  637.  
  638. ¥ Is there pending input from the Mops window?
  639.  
  640.     get_$input  ?dup
  641.     IF                    ¥ yes - move it to the destination.  We can
  642.                         ¥  assume special chars have been filtered.
  643.         max_len min
  644.         dup #tib !
  645.         addr swap cmove  EXIT
  646.     THEN
  647.     drop
  648.  
  649.     BEGIN
  650.         key_acc  -> c
  651.         c $ D =
  652.         IF  #tib @  EXIT  THEN
  653.         
  654.         #tib @ max_len <
  655.         IF  c  addr #tib @ + c!        ¥ still room in buff - store char
  656.             1 #tib +!
  657.         THEN
  658.     AGAIN
  659. ;
  660.  
  661.  
  662. : SET_SOURCE
  663.     TIB        -> src-start
  664.     #tib @    -> src-len
  665.     0 >in !
  666. ;
  667.  
  668. : QUERY
  669.     TIB TIBlen  accept drop
  670.     set_source
  671.     0 -> source-ID
  672. ;
  673.  
  674. :f REFILL ( -- b )    ¥ attempts to (re)fill the input stream with another line.
  675.     source-ID dup
  676.     NIF                    ¥ it's from the keyboard
  677.         drop  query
  678.         true
  679.     ELSE
  680.         -1 =
  681.         IF                ¥ it's from an EVALUATEd string - none left
  682.             false
  683.         ELSE            ¥ it's from a file
  684.             fRefill        ¥ - fRefill does the job, and returns the flag.
  685.         THEN
  686.     THEN
  687.     1 ++> #lines_read
  688. ;f
  689.  
  690.  
  691. ¥                    =====================
  692. ¥                        NUMBER INPUT
  693. ¥                    =====================
  694.  
  695.  
  696. : >NUMBER  ( ud-lo ud-hi ) { addr len -- ud-lo' ud-hi' addr' len' }
  697.     len 0>
  698.     IF
  699.         BEGIN
  700.             addr c@  1 ++> addr
  701.             base digit
  702.             NIF    1 --> addr  false
  703.             ELSE
  704.              ( ud-lo ud-hi digit )
  705.                  swap base * rot base um*  d+
  706.                 dpl 0>= IF  1 ++> dpl  THEN
  707.                 1 --> len
  708.                 len 0>
  709.             THEN
  710.         NUNTIL
  711.     THEN
  712.     ( ud-lo' ud-hi' )  addr len
  713. ;
  714.  
  715.  
  716. : ?NOTFOUND  ( flag -- )
  717.     NIF     -13 die  THEN        ¥ "undefined word"
  718. ;
  719.  
  720.  
  721. : NUM?  { addr len ¥ start neg? done? -- n true | -- n-lo n-hi true | -- false }
  722.  
  723.     false -> neg?  false -> done?
  724.  
  725.     len NIF  false  EXIT  THEN
  726.  
  727.     addr c@ & - =
  728.     IF            ¥ 1st char was minus
  729.         true -> neg?
  730.         1 ++> addr  1 --> len
  731.     THEN
  732.     addr -> start                ¥ remember initial addr
  733.     -1 -> dpl                    ¥ no decimal point seen yet
  734.     0 0                            ¥ initial number is a double zero
  735.     BEGIN
  736.         addr len  >number        ¥ accumulate digits into number
  737.         -> len -> addr            ¥ update string addr & len
  738.         len
  739.         IF    addr c@  & . =
  740.             IF  addr -> dpl
  741.                 1 ++> addr  1 --> len
  742.             ELSE
  743.                 true -> done?
  744.             THEN
  745.         ELSE
  746.             true -> done?
  747.         THEN
  748.     done?
  749.     UNTIL
  750.  
  751. ¥ we've hit a non-digit or the string is exhausted.
  752.  
  753.     len IF            2drop false  EXIT  THEN        ¥ 'number' not completed - probably
  754.                                                 ¥  bad char in number
  755.     addr start = IF    2drop false  EXIT  THEN        ¥ no chars processed - not a number
  756.  
  757.     dpl 0>=
  758.     IF                ¥ decimal point seen - it's a double number
  759.         neg? IF  dnegate  THEN
  760.     ELSE
  761.         drop        ¥ want a single number - drop hi cell
  762.         neg? IF  negate  THEN
  763.     THEN
  764.     true
  765. ;
  766.  
  767. : NUMBER  ( addr -- n )        ¥ returns the number at addr, or if none,
  768.                             ¥ gives "undefined word" error.
  769.     count  num? ?notFound  ;
  770.  
  771.  
  772. ¥ LITERAL is immediate so we'll leave it till the end.
  773.  
  774. ¥    head    $47,LITERAL,literal        ; LITERAL
  775. ¥    callh    hLiteral
  776. ¥    RTS
  777.  
  778.  
  779. ¥            =============================
  780. ¥                       NUMBER OUTPUT
  781. ¥            =============================
  782.  
  783. : HOLD  ( c -- )
  784.     1 --> hld  hld c!  ;
  785.  
  786.  
  787. : <#  ( d -- d )
  788.     pad -> hld  ;
  789.  
  790. : #>  ( d -- )
  791.     2drop
  792.     hld pad over -  ;
  793.  
  794.  
  795. : SIGN  ( n -- )
  796.     0< IF  & -  hold  THEN  ;
  797.  
  798. (*
  799. : #
  800.     drop        ¥ get rid of hi-order cell (assumed to be zero)
  801.     base  u/mod
  802.     swap
  803.     dup 9 > IF  7 +  THEN
  804.     & 0  +  hold
  805.     0
  806. ;
  807. *)
  808.  
  809. : #
  810.     base 0  ud/mod  2swap drop
  811.     dup 9 > IF  7 +  THEN
  812.     & 0  +  hold
  813. ;
  814.  
  815.  
  816. : #S  ( d -- d' )
  817.     BEGIN  #  2dup or  NUNTIL  ;
  818.  
  819. ¥ : HEX        16 -> base  ;
  820. ¥ : DECIMAL    10 -> base  ;
  821.  
  822.  
  823. : .R  { n #to-right -- }
  824.     n abs  0
  825.     <#  #s  n sign  #>
  826.     #to-right over -  spaces
  827.     type
  828. ;
  829.  
  830. : .        ¥ ( n -- )
  831.     0 .r space  ;
  832.  
  833. : .H
  834.     base  16 -> base
  835.     swap .
  836.     -> base  ;
  837.  
  838. : U.
  839.     0 <# #s #>  type  space  ;
  840.  
  841.  
  842. : N>COUNT
  843.     count  $ 1F and  ;
  844.  
  845.